HPAVC/HPAVC CD-ROM.iso/pc/MYMUD21.ZIP/MMUD21.ZIP/SOURCE/SOURCE.ZIP/BIN_DB.PAS

Pascal/Delphi Source File | 1995-01-21 | 15.1 KB | 535 lines

{$I COPYRGHT.INC}

(*----------------------------------------------------------------------------*

   Binary database routines. Implements a binary database for MyMUD. The
   database itself is modelled after the tinymud database.

 *---------------------------------------------------------------------------*)

Unit BIN_DB;
interface
Uses Dos,Header,MyIO,Out_Proc;

Type Database = Object
                  ObjRec  : ObjRecord;         { Hold the current objectrecord }
                  TxtRec  : TextRecord;        { Hold the current text         }

                  ObjFile : File of ObjRecord;
                  TxtFile : File;

                  DBName  : ComStr;         { The name of the current database }
                  CObjNr  : Integer;        { The last read objectrecord       }

                  { The player functions. Search and modify the .PLY file      }

                  Function FindPlayer(UserName : NameString):Integer;
                  Procedure AddPlayer(ObjNr : Integer);

                  { The Database functions. Search and modify the .IDX file    }

                  Procedure Init;
                  Procedure ReadObj(Nr : Integer);
                  Function  ExistObj(Nr : Integer):Boolean;
                  Procedure UpdateObj(Nr : Integer);
                  Function AddObj:integer;
                  Procedure WriteRecord;
                  Procedure Final;
                  Procedure ResetAll;

                  { The description file functions. Search and modify the.TXT  }
                  { file                                                       }

                  Procedure Describe(Msg : String);
                  Procedure Finger(Msg : String);
                  Function  Macro:String;
                  Procedure OFail(Msg : String);
                  Procedure OSuccess(Msg : String);
                  Procedure Fail(Msg : String);
                  Procedure Success(Msg : String);
                  Function Name:String;

                  { the flag functions.                                       }

                  Function IsRoom:Boolean;
                  Function IsThing:Boolean;
                  Function IsExit:Boolean;
                  Function IsPlayer:Boolean;
                  Function IsDrone:Boolean;

                  Function LevelOk(Level : Byte):Boolean;

                  Function IsTemple:Boolean;
                  Function IsHaven:Boolean;
                  Function IsShop:Boolean;
                  Function IsLoud:Boolean;

                  Function CanTeleport:Boolean;

                  Function IsLinkOk:Boolean;
                  Function IsSticky:Boolean;
                  Function IsInvisible:Boolean;
                  Function IsForSale:Boolean;
                  Function IsChownOK:Boolean;

                  Function IsOwnedBy(Player : Integer):Boolean;
                  Function IsOwner(ObjNr : Integer):Boolean;

                  Function WhichGender:GenderType;



               End;

Type ContextType = Record
                    Player     : Integer;
                    Room       : Integer;
                    PlayerName : String[40];
                    Level      : Byte;
                    Gender     : GenderType;
                    Note       : String[50];
                    DB         : Database;
                   End;


Function MaxLen(Len : Word):Word;

Implementation
Uses Misc;

Function MaxLen(Len : Word):Word;
Begin
If Len>Header.DescMax
   Then MaxLen:=Header.DescMax
   Else MaxLen:=Len;
End;


(*---------------------------------------------------------------------------*
   Converts a string to all uppercase
 *---------------------------------------------------------------------------*)
Function UpStr(S : String):String;
Var C : Byte;
Begin
For C:=1 To Length(S) Do
 S[C]:=Upcase(S[C]);
UpStr:=S;
End;

(*---------------------------------------------------------------------------*
   Find a player in the database
 *---------------------------------------------------------------------------*)
Function Database.FindPlayer(UserName : NameString):Integer;
Var Ply : File of Integer;
    Rec : Integer;
Begin
ResetAll;
FileMode:=ReadWrite+ShareDenyNone;
Assign(PLY,DBName+'.PLY');
Reset(PLY);
While (Not Eof(Ply)) and (UpStr(Name)<>UpStr(UserName)) Do
 Begin
 Read(Ply,Rec);
 ReadObj(Rec);
 End;
Close(Ply);
If UpStr(Name)<>UpStr(UserName)
   Then FindPlayer:=NOTHING
   Else FindPlayer:=Rec;
End;

(*---------------------------------------------------------------------------*
   Add a new user to the .PLY file.
 *---------------------------------------------------------------------------*)
Procedure Database.AddPlayer(ObjNr : Integer);
Var Ply : File of Integer;
Begin
FileMode:=ReadWrite+ShareDenyNone;
Assign(PLY,DBName+'.PLY');
Reset(PLY);
Seek(PLY,FileSize(PLY));
Write(PLY,ObjNr);
Close(Ply);
If IoResult<>0
   Then Halt(1);
End;

(*---------------------------------------------------------------------------*
   Initialize the database functions. Always call first!
 *---------------------------------------------------------------------------*)
Procedure Database.Init;
Begin
DBName:=ParamStr(1);
If Pos('.',DBName)>0
   Then DBName:=Copy(DBName,1,Pos('.',DBName)-1);

FileMode:=ReadWrite+ShareDenyNone;
Assign(OBJFile,DBName+'.IDX');
Reset(OBJFile);
Assign(TXTFile,DBName+'.DAT');
Reset(TXTFile,1);

FillChar(ObjRec,SizeOf(ObjRec),#00);
FillChar(TxtRec,SizeOf(TxtRec),#00);
CObjNr :=NOTHING;
End;

(*---------------------------------------------------------------------------*
   Read a record from the file
 *---------------------------------------------------------------------------*)
Procedure DataBase.ReadObj(Nr : Integer);
Begin
If (Nr=CObjNr)
   Then Exit
   Else CObjNr:=Nr;
Seek(ObjFile,Nr);
Read(ObjFile,ObjRec);
If IoResult<>0
   Then Halt(2);
End;

Function DataBase.ExistObj(Nr : Integer):Boolean;
Var Old : LongInt;
    Tmp : LongInt;
Begin
Old:=FilePos(ObjFile);
Tmp:=FileSize(ObjFile);
ExistObj:=Tmp>=Nr;
Seek(ObjFile,Old);
End;

Procedure Database.UpdateObj(Nr : Integer);
Begin
Seek(ObjFile,Nr);
Write(ObjFile,ObjRec);
If IoResult<>0
   Then Begin
        My_WriteLn('ObjRec nr. '+Nr2Str(Nr));
        RunError(2);
        End;
CObjNr:=NOTHING;
End;


(*---------------------------------------------------------------------------*
   Reset the database records.
 *---------------------------------------------------------------------------*)
Procedure DataBase.ResetAll;
Begin
FillChar(ObjRec,SizeOf(ObjRec),#00);
FillChar(TxtRec,SizeOf(TxtRec),#00);
CObjNr :=NOTHING;
End;

(*---------------------------------------------------------------------------*
   Close the databasefiles.
 *---------------------------------------------------------------------------*)
Procedure Database.Final;
Begin
Close(TxtFile);
Close(ObjFile);
End;


(*---------------------------------------------------------------------------*
  Add an object to the database
 *---------------------------------------------------------------------------*)
Function DataBase.AddObj:Integer;
VAR NewNr:Integer;
Begin
NewNr:=FileSize(ObjFile);
Seek(ObjFile, NewNr);
Write(ObjFile,ObjRec);
AddObj:=NewNr;
End;

(*---------------------------------------------------------------------------*
  Write the contents of the current record. (Debugging!)
 *---------------------------------------------------------------------------*)
Procedure Database.WriteRecord;
Begin
With ObjRec Do
 Begin
 My_WriteLn('=================[Record]==========================');
 My_WriteLn('ObjNr    : '+Nr2Str(CObjNr));
 My_WriteLn('Name     : '+Name);
 My_WriteLn('Password : '+Password);
 My_WriteLn('Key      : '+Key);
 My_WriteLn('Location : '+Nr2Str(Location));
 My_WriteLn('Contents : '+Nr2Str(Contents));
 My_WriteLn('Exits    : '+Nr2Str(Exits));
 My_WriteLn('Next     : '+Nr2Str(Next));
 My_WriteLn('Owner    : '+Nr2Str(Owner));
 My_WriteLn('Pennies  : '+Nr2Str(Pennies));
 My_WriteLn('Type     : '+Nr2Str(ObjType));
 My_WriteLn('Level    : '+Nr2Str(ObjLevel));
 My_WriteLn('Garbage  : '+Nr2Str(Garbage));
 My_WriteLn('Sex      : '+Nr2Str(Sex));
 My_WriteLn('GFlags   : '+Nr2Str(GenFlags));
 My_WriteLn('AFlags   : '+Nr2Str(Attr_Flags));
 My_WriteLn('RFlags   : '+Nr2Str(Room_Flags));
 My_WriteLn('');
 End;
End;

(*---------------------------------------------------------------------------*
  Write the description of the current object
 *---------------------------------------------------------------------------*)
Procedure Database.Describe(Msg : String);
Var RR : Word;
    Cnt: Word;
    Len: Word;
Begin
FillChar(TxtRec,SizeOf(TxtRec),#00);
If ObjRec.Desc.Length<>0
   Then Begin
        Seek(TxtFile,ObjRec.Desc.Start);
        BlockRead(TxtFile,TxtRec,MaxLen(ObjRec.Desc.Length),RR);
        End
   Else Move(Msg[1],TxtRec[0],Length(Msg));
If TxtRec[0]=#00
   Then My_WriteLn('You don''t see anything special.')
   Else WriteText(TxtRec);
End;

(*---------------------------------------------------------------------------*
  Write the fingerinfo of the current object
 *---------------------------------------------------------------------------*)
Procedure Database.Finger(Msg : String);
Var RR : Word;
    Cnt: Word;
    Len: Word;
Begin
FillChar(TxtRec,SizeOf(TxtRec),#00);
If ObjRec.Finger.Length<>0
   Then Begin
        Seek(TxtFile,ObjRec.Finger.Start);
        BlockRead(TxtFile,TxtRec,MaxLen(ObjRec.Finger.Length),RR);
        End
   Else Move(Msg[1],TxtRec[0],Length(Msg));
If TxtRec[0]=#00
   Then My_WriteLn('You don''t see anything special.')
   Else WriteText(TxtRec);
End;

(*---------------------------------------------------------------------------*
   Return a macro string
 *---------------------------------------------------------------------------*)
Function Database.Macro:String;
Var RR : Word;
    Cnt: Word;
    S  : String;
Begin
FillChar(TxtRec,SizeOf(TxtRec),#00);
Seek(TxtFile,ObjRec.Macro.Start);
BlockRead(TxtFile,TxtRec,MaxLen(ObjRec.Macro.Length),RR);
Cnt:=0;
S:='';
While (Cnt<=RR) and (Length(S)<255) Do
 Begin
 Case TxtRec[Cnt] of
  #00 : ;
  #13 : Begin
        If TxtRec[Cnt+1]=#10
           then Inc(Cnt);
        S:=S+'^';
        End;
  #10 : Begin
        If TxtRec[Cnt+1]=#13
           then Inc(Cnt);
        S:=S+'^';
        End;
  #9  : S:=S+' ';
  #8  : ;
  Else S:=S+TxtRec[Cnt];
 End;
 Inc(Cnt);
 End;
Macro:=S;
End;

(*---------------------------------------------------------------------------*
  Write the FAIL tekst of the current record
 *---------------------------------------------------------------------------*)
Procedure Database.Fail(Msg : String);
Var RR : Word;
    Cnt: Word;
    Len: Word;
Begin
FillChar(TxtRec,SizeOf(TxtRec),#00);
If ObjRec.Fail.Length<>0
   Then Begin
        Seek(TxtFile,ObjRec.Fail.Start);
        BlockRead(TxtFile,TxtRec,MaxLen(ObjRec.Fail.Length),RR);
        End
   Else Move(Msg[1],TxtRec[0],Length(Msg));
End;

(*---------------------------------------------------------------------------*
  Write the SUCCESS tekst of the current record
 *---------------------------------------------------------------------------*)
Procedure Database.Success(Msg : String);
Var RR : Word;
    Cnt: Word;
    Len: Word;
Begin
FillChar(TxtRec,SizeOf(TxtRec),#00);
If ObjRec.Success.Length<>0
   Then Begin
        Seek(TxtFile,ObjRec.Success.Start);
        BlockRead(TxtFile,TxtRec,MaxLen(ObjRec.Success.Length),RR);
        End
   Else Move(Msg[1],TxtRec[0],Length(Msg));
End;

(*---------------------------------------------------------------------------*
  Read the OFAIL tekst of the current record
 *---------------------------------------------------------------------------*)

Procedure Database.OFail(Msg : String);
Var RR : Word;
    Cnt: Word;
    Len: Word;
Begin
FillChar(TxtRec,SizeOf(TxtRec),#00);
If ObjRec.OFail.Length<>0
   Then Begin
        Seek(TxtFile,ObjRec.OFail.Start);
        BlockRead(TxtFile,TxtRec,MaxLen(ObjRec.OFail.Length),RR);
        End
   Else Move(Msg[1],TxtRec[0],Length(Msg));
End;

(*---------------------------------------------------------------------------*
  Read the OSUCCESS tekst of the current record
 *---------------------------------------------------------------------------*)
Procedure Database.OSuccess(Msg : String);
Var RR : Word;
    Cnt: Word;
    Len: Word;
Begin
FillChar(TxtRec,SizeOf(TxtRec),#00);
If ObjRec.OSuccess.Length<>0
   Then Begin
        Seek(TxtFile,ObjRec.OSuccess.Start);
        BlockRead(TxtFile,TxtRec,MaxLen(ObjRec.OSuccess.Length),RR);
        End
   Else Move(Msg[1],TxtRec[0],Length(Msg));
End;

(*---------------------------------------------------------------------------*
  Return the name of the current object
 *---------------------------------------------------------------------------*)
Function Database.Name:String;
Begin
If Pos(';',ObjRec.Name)>0
   Then Name:=Copy(ObjRec.Name,1,Pos(';',ObjRec.Name)-1)
   Else Name:=ObjRec.Name;
End;

(*---------------------------------------------------------------------------*
  Functions to check the used flags.
 *---------------------------------------------------------------------------*)
Function Database.IsRoom:Boolean;
Begin
IsRoom:=ObjRec.ObjType = Room_Type;
End;

Function Database.IsThing:Boolean;
Begin
IsThing:=ObjRec.ObjType = Thing_Type;
End;

Function Database.IsExit:Boolean;
Begin
IsExit:=ObjRec.ObjType = Exit_Type;
End;

Function Database.IsPlayer:Boolean;
Begin
IsPlayer:=ObjRec.ObjType = Player_Type;
End;

Function Database.IsDrone:Boolean;
Begin
IsDrone:=ObjRec.ObjType = DRONE_Type;
End;


Function Database.LevelOk(Level : Byte):Boolean;
Begin
LevelOk:=ObjRec.ObjLevel>=Level;
End;


Function DataBase.IsLinkOk:Boolean;
Begin
IsLinkOk:=(ObjRec.Attr_Flags And Link_Ok_Flag)=Link_Ok_Flag;
End;

Function Database.IsSticky:Boolean;
Begin
IsSticky:=(ObjRec.Attr_Flags And Sticky_Flag) = Sticky_Flag;
End;

Function Database.IsInvisible:Boolean;
Begin
IsInvisible:=(ObjRec.Attr_Flags And InVisible_Flag) = InVisible_Flag;
End;

Function DataBase.IsForSale:Boolean;
Begin
IsForSale:=(ObjRec.Attr_Flags And For_Sale_Flag)=For_Sale_Flag;
End;

Function DataBase.IsChownOK:Boolean;
Begin
IsChownOK:=(ObjRec.Attr_Flags And Chown_ok_Flag)=Chown_ok_Flag;
End;


Function Database.IsTemple:Boolean;
Begin
IsTemple:=(ObjRec.Room_Flags And Temple_Room)=Temple_Room;
End;

Function Database.IsHaven:Boolean;
Begin
IsHaven:=(ObjRec.Room_Flags And Haven_Room)=Haven_Room;
End;

Function Database.IsShop:Boolean;
Begin
IsShop:=(ObjRec.Room_Flags And Shop_Room)=Shop_Room;
End;

Function Database.IsLoud:Boolean;
Begin
IsLoud:=(ObjRec.Room_Flags And Loud_Room)=Loud_Room;
End;

Function Database.CanTeleport:Boolean;
Begin
CanTeleport:=(ObjRec.Attr_Flags And Teleport_Ok_Flag)=Teleport_Ok_Flag;
End;



Function Database.IsOwnedBy(Player : Integer):Boolean;
Begin
IsOwnedBy:=ObjRec.Owner=Player;
End;

Function DataBase.IsOwner(ObjNr : Integer):Boolean;
Begin
IsOwner:=ObjRec.Owner=ObjNr;
End;


Function Database.WhichGender:GenderType;
Begin
WhichGender:=GenderType(ObjRec.Sex);
End;

End.